Usenet 1993 July/InfoMagic USENET CD-ROM July 1993.ISO/sources/unix/volume10/comobj.lisp/part09

Text File | 1987-08-01 | 35.2 KB | 933 lines

Path: uunet!rs
From: [e-mail] (Rich Salz)
Newsgroups: comp.sources.unix
Subject: v10i083:  Common Objects, Common Loops, Common Lisp, Part09/13
Message-ID: <[e-mail]>
Date: 3 Aug 87 03:03:36 GMT
Organization: UUNET Communications Services, Arlington, VA
Lines: 922
Approved: [e-mail]

Submitted-by: Roy D'Souza <[e-mail]>
Posting-number: Volume 10, Issue 83
Archive-name: comobj.lisp/Part09

#! /bin/sh
# This is a shell archive.  Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file".  To overwrite existing
# files, type "sh file -c".  You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g..  If this archive is complete, you
# will see the following message at the end:
#        "End of archive 9 (of 13)."
# Contents:  walk.l
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'walk.l' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'walk.l'\"
else
echo shar: Extracting \"'walk.l'\" \(33372 characters\)
sed "s/^X//" >'walk.l' <<'END_OF_FILE'
X;;;-*- Mode:LISP; Package:(WALKER LISP 1000); Base:10; Syntax:Common-lisp -*-
X;;;
X;;; *************************************************************************
X;;; Copyright (c) 1985 Xerox Corporation.  All rights reserved.
X;;;
X;;; Use and copying of this software and preparation of derivative works
X;;; based upon this software are permitted.  Any distribution of this
X;;; software or derivative works must comply with all applicable United
X;;; States export control laws.
X;;;
X;;; This software is made available AS IS, and Xerox Corporation makes no
X;;; warranty about the software, its performance or its conformity to any
X;;; specification.
X;;;
X;;; Any person obtaining a copy of this software is requested to send their
X;;; name and post office or electronic mail address to:
X;;;   CommonLoops Coordinator
X;;;   Xerox Artifical Intelligence Systems
X;;;   2400 Hanover St.
X;;;   Palo Alto, CA 94303
X;;; (or send Arpanet mail to [e-mail])
X;;;
X;;; Suggestions, comments and requests for improvements are also welcome.
X;;; *************************************************************************
X;;;
X;;; A simple code walker, based IN PART on: (roll the credits)
X;;;   Larry Masinter's Masterscope
X;;;   Moon's Common Lisp code walker
X;;;   Gary Drescher's code walker
X;;;   Larry Masinter's simple code walker
X;;;   .
X;;;   .
X;;;   boy, thats fair (I hope).
X;;;
X;;; For now at least, this code walker really only does what PCL needs it to
X;;; do.  Maybe it will grow up someday.
X;;;
X
X(in-package 'walker)
X
X(export '(define-walker-template
X      walk-form
X      variable-lexical-p
X      variable-special-p
X      ))
X
X;;; *walk-function* is the function being called on each sub-form as we walk.
X;;; Normally it is supplied using the :walk-function keyword argument to
X;;; walk-form, but it is OK to bind it around a call to walk-form-internal.
X(defvar *walk-function*)
X
X;;; *walk-form* is used by the IF template.  When the first argument to the
X;;; if template is a list it will be evaluated with *walk-form* bound to the
X;;; form currently being walked.
X(defvar *walk-form*)
X
X;;; *declarations* is a list of the declarations currently in effect.
X(defvar *declarations*)
X
X;;; *lexical-variables* is a list of the variables bound in the current
X;;; contour. In *lexical-variables* the cons whose car is the variable is
X;;; meaningful in the sense that the cons whose car is the variable can be
X;;; used to keep track of which contour the variable is bound in.
X;;;
X;;; Now isn't that just the cats pajamas.
X;;;
X(defvar *lexical-variables*)
X
X;;; An environment of the kind that macroexpand-1 gets as its second
X;;; argument.  In fact, that is exactly where it comes from.  This is kind of
X;;; kludgy since Common Lisp is somewhat screwed up in this respect.
X;;; Hopefully Common Lisp will fix this soon.  For more info see:
X;;; MAKE-LEXICAL-ENVIRONMENT
X(defvar *environment*)
X
X;;;
X;;; With new contour is used to enter a new lexical binding contour which
X;;; inherits from the exisiting one.  I admit that using with-new-contour is
X;;; often overkill.  It would suffice for the the walker to rebind
X;;; *lexical-variables* and *declarations* when walking LET and rebind
X;;; *environment* and *declarations* when walking MACROLET etc.
X;;; WITH-NEW-CONTOUR is much more convenient and just as correct.
X;;;
X(defmacro with-new-contour (&body body)
X  `(let ((*declarations* ())            ;If Common Lisp got an
X                        ;unspecial declaration
X                        ;this would need to be
X                        ;re-worked.
X         (*lexical-variables* *lexical-variables*)
X         (*environment* *environment*))
X     . ,body))
X
X(defmacro note-lexical-binding (thing)
X  `(push ,thing *lexical-variables*))
X
X(defmacro note-declaration (declaration)
X  `(push ,declaration *declarations*))
X
X
X(defun variable-lexically-boundp (var)
X  (if (not (boundp '*walk-function*))
X      :unsure
X      (values (member var *lexical-variables* :test (function eq))
X          (variable-special-p var) 't)))
X
X(defun variable-lexical-p (var)
X  (if (not (boundp '*walk-function*))
X      :unsure
X      (and (not (eq (variable-special-p var) 't))
X       (member var *lexical-variables* :test (function eq)))))
X
X(defun variable-special-p (var)
X  (if (not (boundp '*walk-function*))
X      (or (variable-globally-special-p var) :unsure)
X      (or (dolist (decl *declarations*)
X        (and (eq (car decl) 'special)
X         (member var (cdr decl) :test #'eq)
X         (return t)))
X      (variable-globally-special-p var))))
X
X;;;
X;;; VARIABLE-GLOBALLY-SPECIAL-P is used to ask if a variable has been
X;;; declared globally special.  Any particular CommonLisp implementation
X;;; should customize this function accordingly and send their customization
X;;; back.
X;;;
X;;; The default version of variable-globally-special-p is probably pretty
X;;; slow, so it uses *globally-special-variables* as a cache to remember
X;;; variables that it has already figured out are globally special.
X;;;
X;;; This would need to be reworked if an unspecial declaration got added to
X;;; Common Lisp.
X;;;
X;;; Common Lisp nit:
X;;;   variable-globally-special-p should be defined in Common Lisp.
X;;;
X#-(or Symbolics Xerox TI VaxLisp KCL LMI excl)
X(defvar *globally-special-variables* ())
X
X(defun variable-globally-special-p (symbol)
X  #+Symbolics                   (si:special-variable-p symbol)
X  #+(or Lucid TI LMI)           (get symbol 'special)
X  #+Xerox                       (il:variable-globally-special-p symbol)
X  #+VaxLisp                     (get symbol 'system::globally-special)
X  #+KCL                    (si:specialp symbol)
X  #+excl                        (get symbol 'excl::.globally-special.)
X  #+HP                          (member (get symbol 'impl:vartype)
X                    '(impl:fluid impl:global)
X                    :test #'eq)
X  #-(or Symbolics Lucid TI LMI Xerox VaxLisp KCL excl HP)
X  (or (not (null (member symbol *globally-special-variables* :test #'eq)))
X      (when (eval `(flet ((ref () ,symbol))
X             (let ((,symbol '#,(list nil)))
X               (and (boundp ',symbol) (eq ,symbol (ref))))))
X    (push symbol *globally-special-variables*)
X    t)))
X
X
X  ;;
X;;;;;; Handling of special forms (the infamous 24).
X  ;;
X;;;
X;;; and I quote...
X;;;
X;;;     The set of special forms is purposely kept very small because
X;;;     any program analyzing program (read code walker) must have
X;;;     special knowledge about every type of special form. Such a
X;;;     program needs no special knowledge about macros...
X;;;
X;;; So all we have to do here is a define a way to store and retrieve
X;;; templates which describe how to walk the 24 special forms and we are all
X;;; set...
X;;;
X;;; Well, its a nice concept, and I have to admit to being naive enough that
X;;; I believed it for a while, but not everyone takes having only 24 special
X;;; forms as seriously as might be nice.  There are (at least) 3 ways to
X;;; lose:
X;;
X;;;   1 - Implementation x implements a Common Lisp special form as a macro
X;;;       which expands into a special form which:
X;;;         - Is a common lisp special form (not likely)
X;;;         - Is not a common lisp special form (on the 3600 IF --> COND).
X;;;
X;;;     * We can safe ourselves from this case (second subcase really) by
X;;;       checking to see if there is a template defined for something
X;;;       before we check to see if we we can macroexpand it.
X;;;
X;;;   2 - Implementation x implements a Common Lisp macro as a special form.
X;;;
X;;;     * This is a screw, but not so bad, we save ourselves from it by
X;;;       defining extra templates for the macros which are *likely* to
X;;;       be implemented as special forms.  (DO, DO* ...)
X;;;
X;;;   3 - Implementation x has a special form which is not on the list of
X;;;       Common Lisp special forms.
X;;;
X;;;     * This is a bad sort of a screw and happens more than I would like
X;;;       to think, especially in the implementations which provide more
X;;;       than just Common Lisp (3600, Xerox etc.).
X;;;       The fix is not terribly staisfactory, but will have to do for
X;;;       now.  There is a hook in get walker-template which can get a
X;;;       template from the implementation's own walker.  That template
X;;;       has to be converted, and so it may be that the right way to do
X;;;       this would actually be for that implementation to provide an
X;;;       interface to its walker which looks like the interface to this
X;;;       walker.
X;;;
X(defmacro get-walker-template-internal (x)
X  `(get ,x 'walker-template))
X
X(defun get-walker-template (x)
X  (cond ((symbolp x)
X     (or (get-walker-template-internal x)
X         (get-implementation-dependent-walker-template x)))
X    ((and (listp x) (eq (car x) 'lambda))
X     '(lambda repeat (eval)))
X    ((and (listp x) (eq (car x) 'lambda))
X     '(call repeat (eval)))))
X
X(defun get-implementation-dependent-walker-template (x)
X  (declare (ignore x))
X  ())
X
X(eval-when (compile load eval)
X(defmacro define-walker-template (name template)
X  `(eval-when (load eval)
X     (setf (get-walker-template-internal ',name) ',template)))
X)
X
X
X  ;;
X;;;;;; The actual templates
X  ;;
X
X(define-walker-template BLOCK                (NIL NIL REPEAT (EVAL)))
X(define-walker-template CATCH                (NIL EVAL REPEAT (EVAL)))
X(define-walker-template COMPILER-LET         walk-compiler-let)
X(define-walker-template DECLARE              walk-unexpected-declare)
X(define-walker-template EVAL-WHEN            (NIL QUOTE REPEAT (EVAL)))
X(define-walker-template FLET                 walk-flet/labels)
X(define-walker-template FUNCTION             (NIL CALL))
X(define-walker-template GO                   (NIL QUOTE))
X(define-walker-template IF                   (NIL TEST RETURN RETURN))
X(define-walker-template LABELS               walk-flet/labels)
X(define-walker-template LAMBDA               walk-lambda)
X(define-walker-template LET                  walk-let)
X(define-walker-template LET*                 walk-let*)
X(define-walker-template MACROLET             walk-macrolet)
X(define-walker-template MULTIPLE-VALUE-CALL  (NIL EVAL REPEAT (EVAL)))
X(define-walker-template MULTIPLE-VALUE-PROG1 (NIL RETURN REPEAT (EVAL)))
X(define-walker-template MULTIPLE-VALUE-SETQ  (NIL (REPEAT (SET)) EVAL))
X(define-walker-template PROGN                (NIL REPEAT (EVAL)))
X(define-walker-template PROGV                (NIL EVAL EVAL REPEAT (EVAL)))
X(define-walker-template QUOTE                (NIL QUOTE))
X(define-walker-template RETURN-FROM          (NIL QUOTE REPEAT (RETURN)))
X(define-walker-template SETQ                 (NIL REPEAT (SET EVAL)))
X(define-walker-template TAGBODY              walk-tagbody)
X(define-walker-template THE                  (NIL QUOTE EVAL))
X(define-walker-template THROW                (NIL EVAL EVAL))
X(define-walker-template UNWIND-PROTECT       (NIL RETURN REPEAT (EVAL)))
X
X;;; The new special form.
X;(define-walker-template pcl::LOAD-TIME-EVAL       (NIL EVAL))
X
X;;;
X;;; And the extra templates...
X;;;
X(define-walker-template DO      walk-do)
X(define-walker-template DO*     walk-do*)
X(define-walker-template PROG    walk-let)
X(define-walker-template PROG*   walk-let*)
X(define-walker-template COND    (NIL REPEAT ((TEST REPEAT (EVAL)))))
X
X
X  ;;
X;;;;;; WALK-FORM
X  ;;
X;;;
X;;; The main entry-point is walk-form, calls back in should use walk-form-internal.
X;;;
X
X(defun walk-form (form &key ((:declarations *declarations*) ())
X                ((:lexical-variables *lexical-variables*) ())
X                ((:environment *environment*) ())
X                ((:walk-function *walk-function*) #'(lambda (x y)
X                                  y x)))
X  (walk-form-internal form 'eval))
X
X;;;
X;;; WALK-FORM-INTERNAL is the main driving function for the code walker. It
X;;; takes a form and the current context and walks the form calling itself or
X;;; the appropriate template recursively.
X;;;
X;;;   "It is recommended that a program-analyzing-program process a form
X;;;    that is a list whose car is a symbol as follows:
X;;;
X;;;     1. If the program has particular knowledge about the symbol,
X;;;        process the form using special-purpose code.  All of the
X;;;        standard special forms should fall into this category.
X;;;     2. Otherwise, if macro-function is true of the symbol apply
X;;;        either macroexpand or macroexpand-1 and start over.
X;;;     3. Otherwise, assume it is a function call. "
X;;;
X
X(defun walk-form-internal (form context
X               &aux newform newnewform
X                walk-no-more-p macrop
X                fn template)
X  ;; First apply the *walk-function* to perform whatever translation
X  ;; the user wants to to this form.  If the second value returned
X  ;; by *walk-function* is T then we don't recurse...
X  (multiple-value-setq (newform walk-no-more-p)
X    (funcall *walk-function* form context))
X  (cond (walk-no-more-p newform)
X    ((not (eq form newform)) (walk-form-internal newform context))
X    ((not (consp newform)) newform)
X    ((setq template (get-walker-template (setq fn (car newform))))
X         (if (symbolp template)
X             (funcall template newform context)
X             (walk-template newform template context)))
X    ((progn (multiple-value-setq (newnewform macrop)
X          (macroexpand-1 newform *environment*))
X        macrop)
X     (walk-form-internal newnewform context))
X    ((and (symbolp fn)
X          (not (fboundp fn))
X          (special-form-p fn))
X     (error
X       "~S is a special form, not defined in the CommonLisp manual.~%~
X            This code walker doesn't know how to walk it.  Please define a~%~
X            template for this special form and try again."
X       fn))
X    (t
X         ;; Otherwise, walk the form as if its just a standard function
X         ;; call using a template for standard function call.
X         (walk-template newform '(call repeat (eval)) context))))
X
X(defun walk-template (form template context)
X  (if (atom template)
X      (ecase template
X        ((QUOTE NIL) form)
X        ((EVAL FUNCTION TEST EFFECT RETURN)
X         (walk-form-internal form :EVAL))
X        (SET
X          (walk-form-internal form :SET))
X        ((LAMBDA CALL)
X     (if (symbolp form)
X         form
X         (walk-lambda form context))))
X      (case (car template)
X        (IF
X          (let ((*walk-form* form))
X            (walk-template form
X               (if (if (listp (cadr template))
X                   (eval (cadr template))
X                   (funcall (cadr template) form))
X                   (caddr template)
X                   (cadddr template))
X               context)))
X        (REPEAT
X          (walk-template-handle-repeat form
X                                       (cdr template)
X                       ;; For the case where nothing happens
X                       ;; after the repeat optimize out the
X                       ;; call to length.
X                       (if (null (cddr template))
X                       ()
X                       (nthcdr (- (length form)
X                              (length
X                            (cddr template)))
X                           form))
X                                       context))
X        (REMOTE
X          (walk-template form (cadr template) context))
X        (otherwise
X          (cond ((atom form) form)
X                (t (recons form
X                           (walk-template
X                 (car form) (car template) context)
X                           (walk-template
X                 (cdr form) (cdr template) context))))))))
X
X(defun walk-template-handle-repeat (form template stop-form context)
X  (if (eq form stop-form)
X      (walk-template form (cdr template) context)
X      (walk-template-handle-repeat-1 form
X                     template
X                     (car template)
X                     stop-form
X                     context)))
X
X(defun walk-template-handle-repeat-1 (form template repeat-template
X                       stop-form context)
X  (cond ((null form) ())
X        ((eq form stop-form)
X         (if (null repeat-template)
X             (walk-template stop-form (cdr template) context)
X             (error "While handling repeat:
X                     ~%~Ran into stop while still in repeat template.")))
X        ((null repeat-template)
X         (walk-template-handle-repeat-1
X       form template (car template) stop-form context))
X        (t
X         (recons form
X                 (walk-template (car form) (car repeat-template) context)
X                 (walk-template-handle-repeat-1 (cdr form)
X                        template
X                        (cdr repeat-template)
X                        stop-form
X                        context)))))
X
X(defun recons (x car cdr)
X  (if (or (not (eq (car x) car))
X          (not (eq (cdr x) cdr)))
X      (cons car cdr)
X      x))
X
X(defun relist* (x &rest args)
X  (relist*-internal x args))
X
X(defun relist*-internal (x args)
X  (if (null (cdr args))
X      (car args)
X      (recons x (car args) (relist*-internal (cdr x) (cdr args)))))
X
X
X  ;;
X;;;;;; Special walkers
X  ;;
X
X(defun walk-declarations (body fn
X                   &optional doc-string-p declarations old-body
X                   &aux (form (car body)))
X  (cond ((and (stringp form)            ;might be a doc string
X              (cdr body)            ;isn't the returned value
X              (null doc-string-p)        ;no doc string yet
X              (null declarations))        ;no declarations yet
X         (recons body
X                 form
X                 (walk-declarations (cdr body) fn t)))
X        ((and (listp form) (eq (car form) 'declare))
X         ;; Got ourselves a real live declaration.  Record it, look for more.
X         (dolist (declaration (cdr form))
X           (note-declaration declaration)
X           (push declaration declarations))
X         (recons body
X                 form
X                 (walk-declarations
X           (cdr body) fn doc-string-p declarations)))
X        ((and form
X          (listp form)
X          (null (get-walker-template (car form)))
X          (not (eq form (setq form (macroexpand-1 form *environment*)))))
X         ;; When we macroexpanded this form we got something else back.
X         ;; Maybe this is a macro which expanded into a declare?
X     ;; Recurse to find out.
X         (walk-declarations
X       (cons form (cdr body)) fn doc-string-p declarations (or old-body
X                                   body)))
X        (t
X         ;; Now that we have walked and recorded the declarations, call the
X     ;; function our caller provided to expand the body.  We call that
X     ;; function rather than passing the real-body back, because we are
X     ;; RECONSING up the new body.
X         (funcall fn (or old-body body)))))
X
X(defun fix-lucid-1.2 (x) x)
X
X(defun walk-unexpected-declare (form context)
X  (declare (ignore context))
X  (warn "Encountered declare ~S in a place where a declare was not expected."
X    form)
X  form)
X
X(defun walk-arglist (arglist context &optional (destructuringp nil) &aux arg)
X  (cond ((null arglist) ())
X        ((symbolp (setq arg (car arglist)))
X         (or (member arg lambda-list-keywords :test #'eq)
X             (note-lexical-binding arg))
X         (recons arglist
X                 arg
X                 (walk-arglist (cdr arglist)
X                               context
X                               (and destructuringp
X                    (not (member arg lambda-list-keywords
X                         :test #'eq))))))
X        ((consp arg)
X         (prog1 (if destructuringp
X                    (walk-arglist arg context destructuringp)
X                    (recons arglist
X                            (relist* arg
X                                     (car arg)
X                                     (walk-form-internal (cadr arg) 'eval)
X                                     (cddr arg))
X                            (walk-arglist (cdr arglist) context nil)))
X                (if (symbolp (car arg))
X                    (note-lexical-binding (car arg))
X                    (note-lexical-binding (cadar arg)))
X                (or (null (cddr arg))
X                    (not (symbolp (caddr arg)))
X                    (note-lexical-binding arg))))
X          (t
X       (error "Can't understand something in the arglist ~S" arglist))))
X
X(defun walk-let (form context)
X  (walk-let/let* form context nil))
X
X(defun walk-let* (form context)
X  (walk-let/let* form context t))
X
X(defun walk-do (form context)
X  (walk-do/do* form context nil))
X
X(defun walk-do* (form context)
X  (walk-do/do* form context t))
X
X(defun walk-let/let* (form context sequentialp)
X  (let ((old-declarations *declarations*)
X    (old-lexical-variables *lexical-variables*))
X    (with-new-contour
X      (let* ((let/let* (car form))
X             (bindings (cadr form))
X             (body (cddr form))
X             walked-bindings
X             (walked-body
X               (walk-declarations
X                 body
X                 #'(lambda (real-body)
X                     (setq walked-bindings
X                           (walk-bindings-1 bindings
X                        old-declarations
X                        old-lexical-variables
X                        context
X                        sequentialp))
X                     (walk-template real-body '(repeat (eval)) context)))))
X        (relist*
X      form let/let* (fix-lucid-1.2 walked-bindings) walked-body)))))
X
X(defun walk-do/do* (form context sequentialp)
X  (let ((old-declarations *declarations*)
X    (old-lexical-variables *lexical-variables*))
X    (with-new-contour
X      (let* ((do/do* (car form))
X             (bindings (cadr form))
X             (end-test (caddr form))
X             (body (cdddr form))
X             walked-bindings
X             (walked-body
X               (walk-declarations
X                 body
X                 #'(lambda (real-body)
X                     (setq walked-bindings
X                           (walk-bindings-1 bindings
X                        old-declarations
X                        old-lexical-variables
X                        context
X                        sequentialp))
X                     (walk-template real-body '(repeat (eval)) context)))))
X        (relist* form
X                 do/do*
X                 (walk-bindings-2 bindings walked-bindings context)
X                 (walk-template end-test '(test repeat (eval)) context)
X                 walked-body)))))
X
X(defun walk-bindings-1 (bindings old-declarations old-lexical-variables
X                 context sequentialp)
X  (and bindings
X       (let ((binding (car bindings)))
X         (recons bindings
X                 (if (symbolp binding)
X                     (prog1 binding
X                            (note-lexical-binding binding))
X                     (prog1 (let ((*declarations* old-declarations)
X                  (*lexical-variables*
X                    (if sequentialp
X                    *lexical-variables*
X                    old-lexical-variables)))
X                              (relist* binding
X                                       (car binding)
X                                       (walk-form-internal (cadr binding)
X                               context)
X                                       (cddr binding)))    ;save cddr for DO/DO*
X                                ;it is the next value
X                                ;form. Don't walk it
X                                ;now though.
X                            (note-lexical-binding (car binding))))
X                 (walk-bindings-1 (cdr bindings)
X                  old-declarations old-lexical-variables
X                  context sequentialp)))))
X
X(defun walk-bindings-2 (bindings walked-bindings context)
X  (and bindings
X       (let ((binding (car bindings))
X             (walked-binding (car walked-bindings)))
X         (recons bindings
X         (if (symbolp binding)
X             binding
X             (relist* binding
X                  (car walked-binding)
X                  (cadr walked-binding)
X                  (walk-template (cddr binding) '(eval) context)))
X                 (walk-bindings-2 (cdr bindings)
X                  (cdr walked-bindings)
X                  context)))))
X
X(defun walk-lambda (form context)
X  (with-new-contour
X    (let* ((arglist (cadr form))
X           (body (cddr form))
X           (walked-arglist nil)
X           (walked-body
X             (walk-declarations body
X           #'(lambda (real-body)
X           (setq walked-arglist (walk-arglist arglist context))
X           (walk-template real-body '(repeat (eval)) context)))))
X      (relist* form
X               (car form)
X               (fix-lucid-1.2 walked-arglist)
X               walked-body))))
X
X(defun walk-tagbody (form context)
X  (recons form (car form) (walk-tagbody-1 (cdr form) context)))
X
X(defun walk-tagbody-1 (form context)
X  (and form
X       (recons form
X               (walk-form-internal (car form)
X                   (if (symbolp (car form)) 'quote context))
X               (walk-tagbody-1 (cdr form) context))))
X
X(defun walk-compiler-let (form context)
X  (with-new-contour
X    (let ((vars ())
X      (vals ()))
X      (dolist (binding (cadr form))
X    (cond ((symbolp binding) (push binding vars) (push nil vals))
X          (t
X           (push (car binding) vars)
X           (push (eval (cadr binding)) vals))))
X      (relist* form
X               (car form)
X               (cadr form)
X               (progv vars vals
X                 (note-declaration (cons 'special vars))
X                 (walk-template (cddr form) '(repeat (eval)) context))))))
X
X(defun walk-macrolet (form context)
X  (labels ((walk-definitions (definitions)
X             (and (not (null definitions))
X                  (let ((definition (car definitions)))
X                    (recons definitions
X                            (with-new-contour
X                              (relist* definition
X                                       (car definition)
X                                       (walk-arglist (cadr definition)
X                             context t)
X                                       (walk-declarations (cddr definition)
X                     #'(lambda (real-body)
X                         (walk-template
X                           real-body
X                           '(repeat (eval))
X                           context)))))
X                            (walk-definitions (cdr definitions)))))))
X    (with-new-contour
X      (relist* form
X               (car form)
X               (walk-definitions (cadr form))
X               (progn (setq *environment*
X                (make-lexical-environment form *environment*))
X                      (walk-declarations (cddr form)
X            #'(lambda (real-body)
X                (walk-template real-body
X                            '(repeat (eval))
X                            context))))))))
X
X(defun walk-flet/labels (form context)
X  (with-new-contour
X    (labels ((walk-definitions (definitions)
X               (if (null definitions)
X                   ()
X                   (recons definitions
X                           (walk-lambda (car definitions) context)
X                           (walk-definitions (cdr definitions)))))
X             (update-environment ()
X               (setq *environment*
X             (make-lexical-environment form *environment*))))
X      (relist* form
X               (car form)
X               (ecase (car form)
X                 (flet
X                   (prog1 (walk-definitions (cadr form))
X                          (update-environment)))
X                 (labels
X                   (update-environment)
X                   (walk-definitions (cadr form))))
X               (walk-declarations (cddr form)
X         #'(lambda (real-body)
X             (walk-template real-body '(repeat (eval)) context)))))))
X
X;;; make-lexical-environemnt is kind of gross.  It would be less gross if
X;;; EVAL took an environment argument.
X;;;
X;;; Common Lisp nit:
X;;;    if Common Lisp should provide mechanisms for playing with
X;;;    environments explicitly.  making them, finding out what
X;;;    functions are bound in them etc.  Maybe compile should
X;;;    take an environment argument too?
X;;;
X
X(defun make-lexical-environment (macrolet/flet/labels-form environment)
X  (evalhook (list (car macrolet/flet/labels-form)
X                  (cadr macrolet/flet/labels-form)
X                  (list 'make-lexical-environment-2))
X            'make-lexical-environment-1
X            ()
X            environment))
X
X(defun make-lexical-environment-1 (form env)
X  (setq form (macroexpand form #-excl env
X                   #+excl (cadr env)))
X  (evalhook form  'make-lexical-environment-1 nil env))
X
X(defmacro make-lexical-environment-2 (&environment env)
X  (list 'quote (copy-tree env)))
X
X  ;;
X;;;;;; Tests tests tests
X  ;;
X
X#|
X
X(defmacro take-it-out-for-a-test-walk (form)
X  `(progn
X     (terpri)
X     (terpri)
X     (let ((copy-of-form (copy-tree ',form))
X           (result (walk-form ',form :walk-function
X                              '(lambda (x y)
X                                 (format t "~&Form: ~S ~3T Context: ~A" x y)
X                                 (when (symbolp x)
X                   (multiple-value-bind (lexical special)
X                       (variable-lexically-boundp x)
X                                     (when lexical
X                                       (format t ";~3T")
X                                       (format t "lexically bound"))
X                                     (when special
X                                       (format t ";~3T")
X                                       (format t "declared special"))
X                                     (when (boundp x)
X                                       (format t ";~3T")
X                                       (format t "bound: ~S " (eval x)))))
X                                 x))))
X       (cond ((not (equal result copy-of-form))
X              (format t "~%Warning: Result not EQUAL to copy of start."))
X             ((not (eq result ',form))
X              (format t "~%Warning: Result not EQ to copy of start.")))
X       (#+Symbolics zl:grind-top-level
X        #-Symbolics print
X                                  result)
X       result)))
X
X(defun foo (&rest ignore) ())
X
X(defmacro bar (x) `'(global-bar-expanded ,x))
X
X(defun baz (&rest ignore) ())
X
X(take-it-out-for-a-test-walk (foo arg1 arg2 arg3))
X(take-it-out-for-a-test-walk (foo (baz 1 2) (baz 3 4 5)))
X
X(take-it-out-for-a-test-walk (block block-name a b c))
X(take-it-out-for-a-test-walk (block block-name (foo a) b c))
X
X(take-it-out-for-a-test-walk (catch catch-tag (foo a) b c))
X(take-it-out-for-a-test-walk (compiler-let ((a 1) (b 2)) (foo a) b))
X(take-it-out-for-a-test-walk (prog () (declare (special a b))))
X(take-it-out-for-a-test-walk (let (a b c)
X                               (declare (special a b))
X                               (foo a) b c))
X(take-it-out-for-a-test-walk (let (a b c)
X                               (declare (special a) (special b))
X                               (foo a) b c))
X(take-it-out-for-a-test-walk (let (a b c)
X                               (declare (special a))
X                               (declare (special b))
X                               (foo a) b c))
X(take-it-out-for-a-test-walk (let (a b c)
X                               (declare (special a))
X                               (declare (special b))
X                               (let ((a 1))
X                                 (foo a) b c)))
X(take-it-out-for-a-test-walk (eval-when ()
X                               a
X                               (foo a)))
X(take-it-out-for-a-test-walk (eval-when (eval when load)
X                               a
X                               (foo a)))
X(take-it-out-for-a-test-walk (progn (function foo)))
X(take-it-out-for-a-test-walk (progn a b (go a)))
X(take-it-out-for-a-test-walk (if a b c))
X(take-it-out-for-a-test-walk (if a b))
X(take-it-out-for-a-test-walk ((lambda (a b) (list a b)) 1 2))
X(take-it-out-for-a-test-walk ((lambda (a b) (declare (special a)) (list a b))
X                  1 2))
X(take-it-out-for-a-test-walk (let ((a a) (b a) (c b)) (list a b c)))
X(take-it-out-for-a-test-walk (let* ((a a) (b a) (c b)) (list a b c)))
X(take-it-out-for-a-test-walk (let ((a a) (b a) (c b))
X                               (declare (special a b))
X                               (list a b c)))
X(take-it-out-for-a-test-walk (let* ((a a) (b a) (c b))
X                               (declare (special a b))
X                               (list a b c)))
X(take-it-out-for-a-test-walk (let ((a 1) (b 2))
X                               (foo bar)
X                               (declare (special a))
X                               (foo a b)))
X(take-it-out-for-a-test-walk (multiple-value-call #'foo a b c))
X(take-it-out-for-a-test-walk (multiple-value-prog1 a b c))
X(take-it-out-for-a-test-walk (progn a b c))
X(take-it-out-for-a-test-walk (progv vars vals a b c))
X(take-it-out-for-a-test-walk (quote a))
X(take-it-out-for-a-test-walk (return-from block-name a b c))
X(take-it-out-for-a-test-walk (setq a 1))
X(take-it-out-for-a-test-walk (setq a (foo 1) b (bar 2) c 3))
X(take-it-out-for-a-test-walk (tagbody a b c (go a)))
X(take-it-out-for-a-test-walk (the foo (foo-form a b c)))
X(take-it-out-for-a-test-walk (throw tag-form a))
X(take-it-out-for-a-test-walk (unwind-protect (foo a b) d e f))
X
X
X(take-it-out-for-a-test-walk (flet ((flet-1 (a b) (list a b)))
X                               (flet-1 1 2)
X                               (foo 1 2)))
X(take-it-out-for-a-test-walk (labels ((label-1 (a b) (list a b)))
X                               (label-1 1 2)
X                               (foo 1 2)))
X(take-it-out-for-a-test-walk (macrolet ((macrolet-1 (a b) (list a b)))
X                               (macrolet-1 a b)
X                               (foo 1 2)))
X
X(take-it-out-for-a-test-walk (macrolet ((foo (a) `(inner-foo-expanded ,a)))
X                               (foo 1)))
X
X(take-it-out-for-a-test-walk (progn (bar 1)
X                                    (macrolet ((bar (a)
X                         `(inner-bar-expanded ,a)))
X                                      (bar 1))))
X
X(take-it-out-for-a-test-walk (progn (bar 1)
X                                    (macrolet ((bar (s)
X                         (bar s)
X                         `(inner-bar-expanded ,s)))
X                                      (bar 2))))
X
X(take-it-out-for-a-test-walk (cond (a b)
X                                   ((foo bar) a (foo a))))
X
X
X(let ((the-lexical-variables ()))
X  (walk-form '(let ((a 1) (b 2))
X        #'(lambda (x) (list a b x y)))
X         :walk-function #'(lambda (form context)
X                (when (and (symbolp form)
X                       (variable-lexical-p form))
X                  (push form the-lexical-variables))
X                form))
X  (or (and (= (length the-lexical-variables) 3)
X       (member 'a the-lexical-variables)
X       (member 'b the-lexical-variables)
X       (member 'x the-lexical-variables))
X      (error "Walker didn't do lexical variables of a closure properly.")))
X
X|#
X
X()
X
END_OF_FILE
if test 33372 -ne `wc -c <'walk.l'`; then
    echo shar: \"'walk.l'\" unpacked with wrong size!
fi
# end of 'walk.l'
fi
echo shar: End of archive 9 \(of 13\).
cp /dev/null ark9isdone
MISSING=""
for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 ; do
    if test ! -f ark${I}isdone ; then
    MISSING="${MISSING} ${I}"
    fi
done
if test "${MISSING}" = "" ; then
    echo You have unpacked all 13 archives.
    rm -f ark[1-9]isdone ark[1-9][0-9]isdone
else
    echo You still need to unpack the following archives:
    echo "        " ${MISSING}
fi
##  End of shell archive.
exit 0
--

Rich $alz            "Anger is an energy"
Cronus Project, BBN Labs    [e-mail]
Moderator, comp.sources.unix    [e-mail]